home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / Morpion 1.0.0 / source / PNL Libraries / MyFMenus.unit < prev    next >
Encoding:
Text File  |  1993-10-07  |  6.9 KB  |  295 lines  |  [TEXT/PJMM]
  1. unit MyFMenus;
  2.  
  3. { From Peter's PNL Libraries }
  4. { Copyright 1992 Peter N Lewis }
  5. { This source may be used for any non-commercial purposes as long as I get a mention }
  6. { in the About box and Docs of any derivative program.  It may not be used in any commercial }
  7. { application without my permission }
  8.  
  9. interface
  10.  
  11.     var
  12.         thefmenu, thefitem: integer;
  13.  
  14.     procedure InitFMenus (default: procptr);
  15. { procedure default(themenu,theitem:integer) }
  16. { Call this once at the start of the application, before all the others }
  17.     procedure FinishFMenus;
  18. { Call this ones as the application quits }
  19.  
  20.     function GetFMenu (id: integer): MenuHandle;
  21. { Call this in place of GetMenu, to read in an fmnu resource.  Use InsertMenu to add it to the menu bar }
  22.     procedure SetFCommand (command: OSType; cmdproc: procptr);
  23. { procedure cmdproc }
  24. { Call this to associate a procedure with a command OSType }
  25.     procedure SetFSetMenu (command: OSType; smproc: procptr);
  26. { procedure smproc(themenu,theitem:integer) }
  27. { Call this to associate a procedure for enabling/disabling the menu item }
  28.     procedure SetFBoth (command: OSType; cmdproc, smproc: procptr);
  29. { This is just a short form to set both the command and SetMenu procedures }
  30.  
  31.     procedure SetFMenus;
  32. { Call this before MenuKey or MenuSelect to set the enables of all the menus }
  33.     procedure DoFMenu (themenu, theitem: integer);
  34. { Call this to act on a menu selection from either MenuSelect or MenuKey }
  35.  
  36. { You probably won't need these }
  37.     procedure AddFCommand (themenu, theitem: integer; command: OSType);
  38. { Call this to associate a menu item with an OSType - normally done by GetFMenu }
  39.     procedure GetCommand (themenu, theitem: integer; var command: OSType);
  40. { Call this to figure out what command OSType is associated with a menu item - normally done via DoFMenu }
  41.     procedure DoCommand (themenu, theitem: integer; command: OSType);
  42. { Call this to execute a menu command - normally done via DoFMenu }
  43.  
  44. implementation
  45.  
  46.     uses
  47.         BaseGlobals;
  48. { import the quitNow variable - this is only used for cosmetic reasons, so that }
  49. { the File menu stays highlighted until the application quits }
  50. { Don't forget that you need to turn on the "Uses" Extensions in the Compile Options }
  51.  
  52.     procedure DoSMP (themenu, theitem: integer; smp: procptr);
  53.     inline
  54.         $205F, $4E90;
  55.  
  56.     procedure DoDefCMDP (themenu, theitem: integer; cmdp: procptr);
  57.     inline
  58.         $205F, $4E90;
  59.  
  60.     procedure DoCMDP (cmdp: procptr);
  61.     inline
  62.         $205F, $4E90;
  63.  
  64.     type
  65.         fmenuHeader = record
  66.                 visible: integer;
  67.                 count: integer;
  68.                 unknown1: integer;
  69.                 menuID: integer;
  70.                 unknown2: integer;
  71.                 unknown3: integer;
  72.                 name: str63;
  73.             end;
  74.         fmenuHeaderPtr = ^fmenuHeader;
  75.         fmenuItem = packed record
  76.                 command: OSType;
  77.                 mark: char;
  78.                 unknown2: byte;
  79.                 cmdKey: char;
  80.                 disabled: byte;
  81.                 name: str63;
  82.             end;
  83.         fmenuItemPtr = ^fmenuItem;
  84.         convertRecord = record
  85.                 menu, item: integer;
  86.                 cmd: OSType;
  87.                 cmdp, smp: procptr;
  88.             end;
  89.         convertArray = array[1..1000] of convertRecord;
  90.         convertPtr = ^convertArray;
  91.         convertHandle = ^convertPtr;
  92.  
  93.     var
  94.         defaultproc: procptr;
  95.         convert_count: integer;
  96.         converts: convertHandle;
  97.  
  98. {$S Init}
  99.     procedure InitFMenus (default: procptr);
  100. { procedure default(themenu,theitem:integer) }
  101.     begin
  102.         defaultproc := default;
  103.         convert_count := 0;
  104.         converts := convertHandle(NewHandle(0));
  105.     end;
  106.  
  107. {$S Term}
  108.     procedure FinishFMenus;
  109.     begin
  110.         DisposHandle(handle(converts));
  111.     end;
  112.  
  113. {$S Init}
  114.     procedure AddFCommand (themenu, theitem: integer; command: OSType);
  115.     begin
  116.         if BAND(convert_count, 7) = 0 then
  117.             SetHandleSize(handle(converts), (convert_count + 8) * SizeOf(convertRecord));
  118.         convert_count := convert_count + 1;
  119.         with converts^^[convert_count] do begin
  120.             menu := themenu;
  121.             item := theitem;
  122.             cmd := command;
  123.             cmdp := defaultproc;
  124.             smp := nil;
  125.         end;
  126.     end;
  127.  
  128. {$S Init}
  129.     procedure NextPtr (var p: univ ptr; sp: univ ptr);
  130.     begin
  131.         p := ptr(longInt(sp) + sp^ + 2 - ord(odd(sp^)));
  132.     end;
  133.  
  134. {$S Init}
  135.     function GetFMenu (id: integer): MenuHandle;
  136.         var
  137.             h: handle;
  138.             mh: menuHandle;
  139.             ph: fmenuHeaderPtr;
  140.             p: fmenuItemPtr;
  141.             s: string[70];
  142.             i: integer;
  143.     begin
  144.         h := GetResource('fmnu', id);
  145.         HLock(h);
  146.         ph := fmenuHeaderPtr(h^);
  147.         mh := NewMenu(ph^.menuID, ph^.name);
  148.         NextPtr(p, @ph^.name);
  149.         for i := 1 to ph^.count do begin
  150.             if p^.name = '-' then
  151.                 AppendMenu(mh, '(-')
  152.             else begin
  153.                 AddFCommand(ph^.menuID, i, p^.command);
  154.                 s := p^.name;
  155.                 if p^.mark <> chr(0) then
  156.                     s := concat(s, '!', p^.mark);
  157.                 if p^.cmdKey <> chr(0) then
  158.                     s := concat(s, '/', p^.cmdKey);
  159.                 if p^.disabled = 1 then
  160.                     s := concat('(', s);
  161.                 AppendMenu(mh, s);
  162.             end;
  163.             NextPtr(p, @p^.name);
  164.         end;
  165.         ReleaseResource(h);
  166.         GetFMenu := mh;
  167.     end;
  168.  
  169. {$S}
  170.     procedure FindCommand (command: OSType; var cmdproc: procptr);
  171.         var
  172.             i: integer;
  173.     begin
  174.         i := 1;
  175.         while i <= convert_count do begin
  176.             with converts^^[i] do
  177.                 if cmd = command then begin
  178.                     cmdproc := cmdp;
  179.                     Exit(FindCommand);
  180.                 end;
  181.             i := i + 1;
  182.         end;
  183.         cmdproc := defaultproc;
  184.     end;
  185.  
  186. {$S}
  187.     procedure FindMenu (themenu, theitem: integer; var i: integer);
  188.     begin
  189.         i := 1;
  190.         while i <= convert_count do begin
  191.             with converts^^[i] do
  192.                 if (menu = themenu) and (item = theitem) then
  193.                     Exit(FindMenu);
  194.             i := i + 1;
  195.         end;
  196.         i := -1;
  197.     end;
  198.  
  199. {$S Init}
  200.     procedure SetFCommand (command: OSType; cmdproc: procptr);
  201. { procedure cmdproc }
  202.         var
  203.             i: integer;
  204.     begin
  205.         for i := 1 to convert_count do
  206.             with converts^^[i] do
  207.                 if cmd = command then
  208.                     cmdp := cmdproc;
  209.     end;
  210.  
  211. {$S Init}
  212.     procedure SetFSetMenu (command: OSType; smproc: procptr);
  213. { procedure smproc }
  214.         var
  215.             i: integer;
  216.     begin
  217.         for i := 1 to convert_count do
  218.             with converts^^[i] do
  219.                 if cmd = command then
  220.                     smp := smproc;
  221.     end;
  222.  
  223. {$S Init}
  224.     procedure SetFBoth (command: OSType; cmdproc, smproc: procptr);
  225. { procedure smproc }
  226.         var
  227.             i: integer;
  228.     begin
  229.         for i := 1 to convert_count do
  230.             with converts^^[i] do
  231.                 if cmd = command then begin
  232.                     cmdp := cmdproc;
  233.                     smp := smproc;
  234.                 end;
  235.     end;
  236.  
  237. {$S}
  238.     procedure GetCommand (themenu, theitem: integer; var command: OSType);
  239.         var
  240.             i: integer;
  241.     begin
  242.         FindMenu(themenu, theitem, i);
  243.         if i = -1 then
  244.             command := 'xxx0'
  245.         else
  246.             command := converts^^[i].cmd;
  247.     end;
  248.  
  249. {$S}
  250.     procedure DoCmd (themenu, theitem: integer; cmdp: procptr);
  251.     begin
  252.         thefmenu := themenu;
  253.         thefitem := theitem;
  254.         if cmdp = defaultproc then
  255.             DoDefCMDP(themenu, theitem, cmdp)
  256.         else
  257.             DoCMDP(cmdp);
  258.     end;
  259.  
  260. {$S}
  261.     procedure DoCommand (themenu, theitem: integer; command: OSType);
  262.         var
  263.             cmdproc: procptr;
  264.     begin
  265.         FindCommand(command, cmdproc);
  266.         DoCmd(themenu, theitem, cmdproc);
  267.     end;
  268.  
  269. {$S}
  270.     procedure DoFMenu (themenu, theitem: integer);
  271.         var
  272.             i: integer;
  273.     begin
  274.         FindMenu(themenu, theitem, i);
  275.         if i = -1 then
  276.             DoCmd(themenu, theitem, defaultproc)
  277.         else
  278.             with converts^^[i] do
  279.                 DoCmd(themenu, theitem, cmdp);
  280.         if not quitNow then
  281.             HiliteMenu(0);
  282.     end;
  283.  
  284. {$S}
  285.     procedure SetFMenus;
  286.         var
  287.             i: integer;
  288.     begin
  289.         for i := 1 to convert_count do
  290.             with converts^^[i] do
  291.                 if smp <> nil then
  292.                     DoSMP(menu, item, smp);
  293.     end;
  294.  
  295. end.